Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/thomas/thomas.lha/Thomas/Thomas-1.1/src/class.scm

Text File | 1992-09-21 | 31KB | 851 lines

;*              Copyright 1992 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;*
;*            Director, Cambridge Research Lab
;*            Digital Equipment Corp
;*            One Kendall Square, Bldg 700
;*            Cambridge MA 02139
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

; $Id: class.scm,v 1.24 1992/09/21 20:41:56 birkholz Exp $

;;;; Class, Instance, and Singleton data types.

;;; Conventions:
;;;
;;; "dylan:" is a prefix used for variables used in the expanded code
;;;          generated by our dylan->scheme compiler.  All such
;;;          functions are expecting to be called using Dylan calling
;;;          syntax (i.e. they send both a multiple-value and a next-method
;;;          argument).  These are typically called from Scheme using the
;;;          dylan-call procedure which defaults the special arguments.
;;;
;;; "dylan::" is a prefix for functions used by the Runtime library, but
;;;           not directly available from Dylan.  These use the normal
;;;           scheme calling convensions.
;;;
;;; Capitalization (per word) is used for Dylan variables defined in
;;; Scheme.

;;; Things visible to converted Dylan code.  Just the names here...

(define dylan::make-a-class '...)
(define Add-Slot '...)
(define Id? eq?)
(define dylan::add-slot '...)
(define dylan::false-fn (lambda () #F))
(define Subclass? '...)
(define map-over-all-superclasses! '...)
(define map-over-all-subclasses! '...)

; (let ()
;;; Scheme structure for representing the Dylan class DAG

(define class-type
  (make-record-type
   'dylan-class
   '(debug-name                ; Name, for debugging
     instances                ; Population of all direct
                    ; instances of this class
     subclasses                ; Population of all direct
                    ; subclasses of this class
     superclasses            ; Ordered list of direct
                    ; superclasses
     slots                ; Vector of slot descriptors
     class-data                ; Vector of data belonging to
                    ; this class -- either from
                    ; CLASS allocated data in one
                    ; of my slots or from
                    ; ALL-SUBCLASSES from
                    ; inherited slots
     instance-data-size            ; Number of slots in each INSTANCE
     sealed?                ; Has the class been sealed?
     read-only?
     abstract?                ; Is the class abstract?
     specificity            ; Longest path from root.
     specificity-token            ; Unique to a specificity labeling.
     )))
(define class? (record-predicate class-type))
(define make-class (record-constructor class-type))
(define class.debug-name (record-accessor class-type 'debug-name))
(define class.instances (record-accessor class-type 'instances))
(define class.subclasses (record-accessor class-type 'subclasses))
(define class.superclasses (record-accessor class-type 'superclasses))
(define class.slots (record-accessor class-type 'slots))
(define class.class-data (record-accessor class-type 'class-data))
(define class.instance-data-size
  (record-accessor class-type 'instance-data-size))
(define class.sealed? (record-accessor class-type 'sealed?))
(define class.read-only? (record-accessor class-type 'read-only?))
(define class.abstract? (record-accessor class-type 'abstract?))
(define class.specificity (record-accessor class-type 'specificity))
(define class.specificity-token (record-accessor class-type 'specificity-token))
(define set-class.instances!
  (record-updater class-type 'instances))
(define set-class.subclasses!
  (record-updater class-type 'subclasses))
(define set-class.superclasses!
  (record-updater class-type 'superclasses))
(define set-class.slots!
  (record-updater class-type 'slots))
(define set-class.class-data!
  (record-updater class-type 'class-data))
(define set-class.instance-data-size!
  (record-updater class-type 'instance-data-size))
(define set-class.sealed?!
  (record-updater class-type 'sealed?))
(define set-class.read-only?!
  (record-updater class-type 'read-only?))
(define set-class.abstract?!
  (record-updater class-type 'abstract?))
(define set-class.specificity! (record-updater class-type 'specificity))
(define set-class.specificity-token!
  (record-updater class-type 'specificity-token))

;;; Scheme structure for representing Dylan singletons

(define singleton-type
  (make-record-type
   'dylan-singleton
   '(object                ; The actual singleton object
     extra-slot-descriptors        ; Vector of slot descriptors
                    ; for slots only in singleton
                    ; and not in class definition
     extra-slot-values)))        ; Vector of extra slot data

(define singleton? (record-predicate singleton-type))
(define make-singleton (record-constructor singleton-type))
(define singleton.object (record-accessor singleton-type 'object))
(define singleton.extra-slot-descriptors
  (record-accessor singleton-type 'extra-slot-descriptors))
(define singleton.extra-slot-values
  (record-accessor singleton-type 'extra-slot-values))
(define set-singleton.extra-slot-descriptors!
  (record-updater singleton-type 'extra-slot-descriptors))
(define set-singleton.extra-slot-values!
  (record-updater singleton-type 'extra-slot-values))

;;; Scheme structure for representing Dylan slot descriptors

;; moved to support.scm -- used by compiler and runtime

;;; Scheme structure for representing Dylan instances

(define instance-type
  (make-record-type
   'dylan-instance
   '(class                ; Direct class of this object
     singleton                ; Singleton for this obj. (or #F)
     data)))                ; Vector of object's instance data
(define instance? (record-predicate instance-type))
(define make-instance (record-constructor instance-type))
(define instance.class (record-accessor instance-type 'class))
(define instance.singleton (record-accessor instance-type 'singleton))
(define instance.data (record-accessor instance-type 'data))
(define set-instance.class! (record-updater instance-type 'class))
(define set-instance.singleton! (record-updater instance-type 'singleton))
(define set-instance.data! (record-updater instance-type 'data))

;;; And now the good stuff ...

(define (test-that-all-slots-for-this-getter-are-identical
     my-slot my-getter slots)
  (define (slots-equal? slot1 slot2)
    (define (slot->list slot)
      (map (lambda (f) (f slot))
       (list slot.debug-name slot.getter slot.setter slot.type
         slot.init-value slot.init-function slot.init-keyword
         slot.required-init-keyword slot.allocation)))
    (define (all? fn l1 l2)
      (or (null? l1)
      (and (fn (car l1) (car l2))
           (all? fn (cdr l1) (cdr l2)))))
    (all? eq? (slot->list slot1) (slot->list slot2)))
  (let loop ((slots slots))
    (cond ((null? slots) #T)
      ((eq? (slot.getter (car slots)) my-getter)
       (if (not (slots-equal? my-slot (car slots)))
           (dylan-call dylan:error
               "multiple inheritance slot clash"
               my-slot (car slots))
           (loop (cdr slots))))
      (else (loop (cdr slots))))))

(define (vector-iterate v fn)
  (do ((length (vector-length v))
       (i 0 (+ i 1)))
      ((= i length))
    (fn i (vector-ref v i))))

(define (grow-vector v . values)
  (let* ((values (list->vector values))
     (n-old-values (vector-length v))
     (new-v (make-vector (+ n-old-values
                (vector-length values)))))
    (vector-iterate v
      (lambda (i entry) (vector-set! new-v i entry)))
    (vector-iterate values
      (lambda (i entry)
    (vector-set! new-v (+ i n-old-values) entry)))
      new-v))

(define (find-empty-slot v)
  (let ((length (vector-length v)))
    (let loop ((i 0))
      (cond ((= i length) #F)
        ((not (vector-ref v i)) i)
        (else (loop (+ i 1)))))))

(define (set-next-vector-entry! vec value update-vec!)
  (let ((next-entry (find-empty-slot vec)))
    (if next-entry
    (vector-set! vec next-entry value)
    (let ((new-vec (grow-vector vec #F #F #F #F #F #F #F #F #F #F)))
      (update-vec! new-vec)
      (set-next-vector-entry! new-vec value update-vec!)))))

(define (copy-slot slot inherited? data-location)
  (apply make-slot
     (map (lambda (fn) (fn slot))
          (list slot.debug-name slot.getter slot.setter
            slot.type slot.init-value
            slot.has-initial-value? slot.init-function
            slot.init-keyword slot.required-init-keyword
            slot.allocation (lambda (s) s inherited?)
            (lambda (s) s data-location)))))

(define (combine-slots class slots new-getter-fns)
  (let ((class-data-index -1)
    (instance-data-index -1))

    (define (figure-slot-data-location slot)
      (case (slot.allocation slot)
    ((CLASS CONSTANT) (slot.data-location slot))
    ((INSTANCE)
     (set! instance-data-index (+ 1 instance-data-index))
     (if (not (= instance-data-index (slot.data-location slot)))
         (begin
           (add-method (slot.getter slot)
               (make-instance-getter class
                         instance-data-index
                         (slot.debug-name slot)))
           (if (slot.setter slot)
           (add-method (slot.setter slot)
                   (make-instance-setter
                class instance-data-index
                (slot.type slot))))))
     instance-data-index)
    ((EACH-SUBCLASS)
     (set! class-data-index (+ 1 class-data-index))
     (if (not (= class-data-index (slot.data-location slot)))
         (begin
           (add-method (slot.getter slot)
               (make-each-subclass-getter class
                              class-data-index
                              (slot.debug-name slot)))
           (if (slot.setter slot)
           (add-method
            (slot.setter slot)
            (make-each-subclass-setter class class-data-index
                           (slot.type slot))))))
     class-data-index)
    ((VIRTUAL) #F)))

    (define (combine-two-slotlists a b)
      ;; NOTE: Question 8 resolved here by using EQ? on the
      ;; superclass slot getter functions
      (let loop ((slots a)
         (getters (map slot.getter a))
         (new-slots b))
    (if (null? new-slots)
        slots
        (let* ((this-slot (car new-slots))
           (this-getter (slot.getter this-slot)))
          (if (memq this-getter getters) ; Slot already inherited?
          (begin
            (if (not (memq this-getter new-getter-fns))
                    ; Not being overridden?
            (test-that-all-slots-for-this-getter-are-identical
             this-slot this-getter slots)) ; Must be identical
            (loop slots getters (cdr new-slots)))
          (loop (cons (copy-slot this-slot
                     #T
                     (figure-slot-data-location this-slot))
                  slots)
            (cons this-getter getters)
            (cdr new-slots)))))))

    (define (reduce fn initial-value l)
      (let loop ((value initial-value)
         (l l))
    (if (null? l)
        value
        (loop (fn value (car l)) (cdr l)))))

    (let ((final-slot-list (reverse (reduce combine-two-slotlists '() slots))))
      (vector (list->vector final-slot-list)
          (+ 1 class-data-index)
          (+ 1 instance-data-index)))))

(define (recompute-class-specificities!)
  (let ((new-token (cons 'SPECIFICITY 'TOKEN)))

    (define (level-me me level)
      (if (eq? new-token (class.specificity-token me))
      (if (> level (class.specificity me))
          (set-class.specificity! me level))
      (begin
        (set-class.specificity-token! me new-token)
        (set-class.specificity! me level)))
      (let ((sublevel (+ 1 level)))
    (map-over-population!
     (class.subclasses me)
     (lambda (subclass)
       (level-me subclass sublevel)))))

    (level-me <object> 0)))

(define (get-initial-slot-value slot)
  (cond ((slot.init-function slot) => (lambda (f) (dylan-call f)))
    ((not (slot.has-initial-value? slot)) *the-uninitialized-slot-value*)
    (else (slot.init-value slot))))

(define (initialize-slot! slot keywords vector which-allocation-types)
  (let ((allocation (slot.allocation slot)))
    (if (memq allocation which-allocation-types)
    (case allocation
      ((INSTANCE EACH-SUBCLASS)
       (let ((keyword (or (slot.required-init-keyword slot)
                  (slot.init-keyword slot))))
         (vector-set! vector (slot.data-location slot)
           (if keyword
           (dylan::find-keyword keywords keyword
             (lambda () (get-initial-slot-value slot)))
           (get-initial-slot-value slot)))))
      ((CLASS)
       (vector-set! vector (cdr (slot.data-location slot))
            (get-initial-slot-value slot)))
      ((VIRTUAL CONSTANT) 'done))))
  'DONE)

(set! dylan::make-a-class
  (lambda (name superclasses new-getter-fns)
    (make-dylan-class name superclasses new-getter-fns #F)))

(define (make-dylan-class name superclasses new-getter-fns top?)
  (if (and (not top?)
       (null? superclasses))
      (dylan-call dylan:error "must specify at least one superclass"))
  (if (not (unique? superclasses memq))
      (dylan-call dylan:error
          "multiple inheritance from identical superclasses"))
  (let* ((the-class
      (make-class
       name                ; debug-name
       (make-population)        ; instances
       (make-population)        ; subclasses
       superclasses            ; superclasses
       '#()                ; slots
       '#()                ; class-data
       0                ; instance-data-size
       #F                ; sealed?
       #F                ; read-only?
       #F                ; abstract?
       #F                ; specificity
       #F                ; specificity-token
       ))
     (combined-slots
      (combine-slots
       the-class
       (map (lambda (class) (vector->list (class.slots class)))
        superclasses)
       new-getter-fns))
     (slots (vector-ref combined-slots 0))
     (class-data-size (vector-ref combined-slots 1))
     (instance-data-size (vector-ref combined-slots 2)))
    (set-class.slots! the-class slots)
    (set-class.class-data!
     the-class
     ;; Design note: we flatten out the slot list here to make
     ;; instance creation fast at the expense of speed of class
     ;; redefinition and space.
     (let ((result
        (make-vector class-data-size *the-uninitialized-slot-value*)))
       (vector-iterate slots
               (lambda (i slot)
             i
             (initialize-slot! slot '() result '(EACH-SUBCLASS))))
       result))
    (set-class.instance-data-size! the-class instance-data-size)
    (for-each
     (lambda (parent-class)
       (add-to-population! (class.subclasses parent-class) the-class))
     superclasses)
    (if (not top?) (recompute-class-specificities!))
    the-class))

(set! Subclass?
  (lambda (class1 class2)
    ; Is class1 a subclass of class2?
    (or (Id? class1 class2)
    (let loop ((classes-left (class.superclasses class1)))
      (cond ((null? classes-left) #F)
        ((Id? class2 (car classes-left)) #T)
        (else (loop (append (class.superclasses (car classes-left))
                    (cdr classes-left)))))))))

(set! Add-Slot
  (lambda (owner . keyword-list)
    ;; Keywords allowed are: getter, setter, type, init-value,
    ;; init-function, init-keyword, required-init-keyword, debug-name, and
    ;; allocation. See page 52.
    (dylan::keyword-validate
     #F keyword-list
     '(getter: setter: type: init-value: init-function: init-keyword:
           required-init-keyword: allocation: debug-name:))
    (let* ((getter (dylan::find-keyword
            keyword-list 'getter:
            (lambda ()
              (dylan-call dylan:error "no getter defined"))))
       (setter (dylan::find-keyword keyword-list 'setter:
                       dylan::false-fn))
       (type (dylan::find-keyword keyword-list 'type:
                     (lambda () <Object>)))
       (have-init-value? #T)
       (init-value (dylan::find-keyword
            keyword-list 'init-value:
            (lambda ()
              (set! have-init-value? #F)
              'no-value)))
       (init-function (dylan::find-keyword
               keyword-list 'init-function:
               dylan::false-fn))
       (init-keyword (dylan::find-keyword
              keyword-list 'init-keyword:
              dylan::false-fn))
       (allocation (dylan::find-keyword
            keyword-list 'allocation:
            (lambda () 'instance)))
       (debug-name (dylan::find-keyword
            keyword-list 'debug-name:
            (lambda () '*the-unnamed-slot*)))
       (required-init-keyword (dylan::find-keyword
                   keyword-list 'required-init-keyword:
                   (lambda () #F))))
      (dylan::add-slot owner
               type allocation setter getter debug-name init-value
               have-init-value? init-function init-keyword
               required-init-keyword))))

(define (same-slot-getter-in-slot-vector->slot getter slots)
  (let loop ((slots (vector->list slots)))
    (cond ((null? slots) #F)
      ((Id? (slot.getter (car slots)) getter) (car slots))
      (else (loop (cdr slots))))))

(define (conflict-test owner new-slot)
  (define (stricter-than-all? type type-list)
    ; type-list may contain #F entries!
    (let loop ((rest-list type-list))
      (cond ((null? rest-list) #T)
        ((or (not (car rest-list)) (subclass? type (car rest-list)))
         (loop (cdr rest-list)))
        (else #F))))
  (if (not (stricter-than-all?
        (slot.type new-slot)
        (map (lambda (class)
           (cond ((same-slot-getter-in-slot-vector->slot
               (slot.getter new-slot)
               (class.slots class)) => slot.type)
             (else #F)))
         (class.superclasses
          (if (class? owner)
              owner
              (instance.class (singleton.object owner)))))))
      (dylan-call
       dylan:error
       "conflict-test -- new slot type not a subclass of inherited type"
       'owner owner
       'new-slot new-slot
       'new-slot-type (slot.type new-slot))))

(define (remove-this-slot-only! owner slot-vector slot)
  (vector-iterate slot-vector
    (lambda (index entry)
      (if (Id? slot entry)
      (let ((allocation (slot.allocation slot))
        (data-location (slot.data-location slot)))
        (vector-set! slot-vector index #F)
        (if (class? owner)
        (case allocation
          ((CLASS)
           (if (eq? (car data-location) owner)
               (vector-set! (class.class-data owner)
                    (cdr data-location)
                    '<<EMPTY-SLOT-VALUE>>)))
          ((EACH-SUBCLASS)
           (vector-set! (class.class-data owner)
                data-location
                '<<EMPTY-SLOT-VALUE>>))
          ((INSTANCE)
           (map-over-population
            (class.instances owner)
            (lambda (ins)
              (vector-set! (instance.data ins)
                   data-location
                   '<<EMPTY-SLOT-VALUE>>)))))
        ;; Not a class, must be a singleton
        (if (eq? allocation 'instance)
            (vector-set! owner
                 data-location
                 '<<EMPTY-SLOT-VALUE>>))))))))

(define (add-a-slot owner new-slot accessor updater fixit-fn)
  ;; Adds new-slot (a slot descriptor) to the owner, using accessor to
  ;; find the current list of slot descriptors and updater to store
  ;; the modified list back if needed.  Fixit-Fn is then called with
  ;; the slot descriptor and owner to update the instances as needed.
  (let* ((current-descriptors (accessor owner))
     (getter (slot.getter new-slot))
     (old-slot (same-slot-getter-in-slot-vector->slot
            getter current-descriptors)))
    (if old-slot
    (begin                ; Redefining existing slot
      (if (slot.inherited? old-slot)
          (conflict-test owner new-slot))
      (remove-this-slot-only! owner current-descriptors old-slot)
      (set! current-descriptors (accessor owner))))
    (let ((offset (find-empty-slot current-descriptors)))
      (if offset
      (vector-set! current-descriptors offset new-slot)
      (updater owner (grow-vector current-descriptors new-slot)))
      (fixit-fn owner new-slot))))

(set! map-over-all-subclasses!
  (lambda (predicate fn classes)
    ;; Predicate is #T if you want to continue to children of this class
    ;; FN receives two arguments: a class and (predicate class)
    ;; Classes appear only once, even if multiple inheritance
    ;; makes a non-tree
    (let loop ((subclasses (population->list classes))
           (already-seen '()))
      (if (null? subclasses)
      'done
      (let* ((this-subclass (car subclasses))
         (test (predicate this-subclass)))
        (if (not (memq this-subclass already-seen))
        (fn this-subclass test))
        (loop (if test
              (append (cdr subclasses)
                  (population->list
                   (class.subclasses (car subclasses))))
              (cdr subclasses))
          (cons this-subclass already-seen)))))))

(set! map-over-all-superclasses!
  (lambda (class fn)
    (let loop ((superclasses (class.superclasses class))
           (already-seen (list class)))
      (if (null? superclasses)
      (reverse already-seen)
      (let ((this-class (car superclasses)))
        (let ((new-ones
           (set-difference (class.superclasses this-class)
                   already-seen
                   memq)))
          (fn this-class)
          (loop (append (cdr superclasses) new-ones)
            (cons this-class already-seen))))))))

(define (add-slot-to-class! class new-slot)
  (case (slot.allocation new-slot)
    ((INSTANCE)
     (map-over-population!
      (class.instances class)
      (lambda (instance)
    (set-instance.data! instance
                (grow-vector (instance.data instance)
                     (get-initial-slot-value new-slot)))))
     (add-method (slot.getter new-slot)
         (make-instance-getter class
                       (class.instance-data-size class)
                       (slot.debug-name new-slot)))
     (if (slot.setter new-slot)
     (add-method (slot.setter new-slot)
             (make-instance-setter class
                       (class.instance-data-size class)
                       (slot.type new-slot))))
     (set-class.instance-data-size! class (+ (class.instance-data-size class)
                         1)))
    ((EACH-SUBCLASS)
     (add-method (slot.getter new-slot)
         (make-each-subclass-getter
          class
          (vector-length (class.class-data class))
          (slot.debug-name new-slot)))
     (if (slot.setter new-slot)
     (add-method (slot.setter new-slot)
             (make-each-subclass-setter
              class
              (vector-length (class.class-data class))
              (slot.type new-slot))))
     (set-class.class-data! class
                (grow-vector (class.class-data class)
                     (get-initial-slot-value new-slot))))
    ((CLASS)
     (let ((data-location (slot.data-location new-slot)))
       (if (eq? class (car data-location))
       (let ((offset (cdr data-location)))
         (set-class.class-data! class
                    (grow-vector
                     (class.class-data class)
                     (get-initial-slot-value new-slot)))
         (add-method (slot.getter new-slot)
             (make-class-getter class
                        offset
                        (slot.debug-name new-slot)))
         (if (slot.setter new-slot)
         (add-method (slot.setter new-slot)
             (make-class-setter class offset
                        (slot.type new-slot))))))))
    ((VIRTUAL CONSTANT) #T)))

(define (add-slot-to-singleton! singleton new-slot)
  (if (eq? (slot.allocation new-slot) 'INSTANCE)
      (begin
    (set-singleton.extra-slot-values!
     singleton
     (grow-vector (singleton.extra-slot-values singleton)
              (get-initial-slot-value new-slot)))
    (add-method (slot.getter new-slot)
            (make-singleton-getter singleton
                       (slot.data-location new-slot)
                       (slot.debug-name new-slot)))
    (if (slot.setter new-slot)
        (add-method (slot.setter new-slot)
            (make-singleton-setter
             singleton (slot.data-location new-slot)
             (slot.type new-slot)))))))

(set! dylan::add-slot
  (lambda (owner type allocation setter getter debug-name init-value
       has-init-value? init-function init-keyword required-init-keyword)
    (define (figure-data-location current-class allocation)
      (if (class? current-class)
      (case allocation        ; CLASS
        ((VIRTUAL) #F)
        ((CONSTANT) init-value)
        ((INSTANCE) (class.instance-data-size current-class))
        ((EACH-SUBCLASS) (vector-length (class.class-data current-class)))
        ((CLASS) (cons owner (vector-length (class.class-data owner)))))
      (case allocation        ; SINGLETON
        ((VIRTUAL) #F)
        ((CONSTANT) init-value)
        ((INSTANCE)
         (vector-length (singleton.extra-slot-values current-class)))
        (else
         (dylan-call dylan:error
             "dylan::add-slot -- bad allocation for singleton"
             current-class debug-name allocation)))))
    (cond ((singleton? owner)
       (if (not (memq allocation '(instance constant virtual)))
           (dylan-call dylan:error
               "dylan::add-slot -- bad singleton allocation"
               allocation))
       (if init-keyword
           (dylan-call dylan:error
               "dylan::add-slot -- singleton with init-keyword"
               init-keyword)))
      ((and (class? owner) (class.read-only? owner))
       (dylan-call dylan:error "add-slot -- class is read-only" owner))
      ((not (class? owner))
       (dylan-call dylan:error
               "dylan::add-slot -- owner not a singleton or class"
               owner)))
    (if (and required-init-keyword
         (or init-keyword has-init-value? init-function))
    (dylan-call dylan:error
            "dylan::add-slot -- incompatible slot initialization"
            'required-init-keyword required-init-keyword
            'init-keyword init-keyword
            'init-value init-value
            'init-function init-function))
    (if (and has-init-value? init-function)
    (dylan-call dylan:error
            "dylan::add-slot -- both initial value and function"
            'init-value init-value
            'init-function init-function))
    (if (not (memq allocation '(instance class each-subclass
                     constant virtual)))
    (dylan-call dylan:error
            "dylan::add-slot -- bad allocation type" allocation))
    (if (and (memq allocation '(class each-subclass))
         (or init-function required-init-keyword init-keyword))
    (dylan-call
     dylan:error
     "dylan::add-slot -- bad combination of allocation and initialization"
     allocation init-function required-init-keyword init-keyword))
    (let ((new-slot (make-slot
             debug-name getter setter type init-value
             has-init-value? init-function init-keyword
             required-init-keyword allocation #F
             (figure-data-location owner allocation))))
      (if (class? owner)
      (begin
        (add-a-slot owner new-slot
            class.slots set-class.slots!
            add-slot-to-class!)
        (map-over-all-subclasses!
         (lambda (class)
           ;; Stop showering down if we hit a class that already has a
           ;; generic function for this slot.
           (not (memq getter (map slot.getter
                      (vector->list (class.slots class))))))
         (lambda (class test)
           (if test
           (add-a-slot
            class
            (copy-slot new-slot #T
                   (figure-data-location class allocation))
            class.slots set-class.slots! add-slot-to-class!)
           (conflict-test class (copy-slot new-slot #T 0))))
         (class.subclasses owner)))
      (add-a-slot owner new-slot    ; SINGLETON
              singleton.extra-slot-descriptors
              set-singleton.extra-slot-descriptors!
              add-slot-to-singleton!))
      new-slot)))

(define (make-getter-param-list class)
  (make-param-list `((OBJ ,class)) #F #F #F))

(define (make-setter-param-list class)
  (make-param-list `((OBJ ,class) (VALUE ,<object>)) #F #F #F))

(define (object-ref data offset object name)
  (let ((value (vector-ref data offset)))
    (if (eq? value *the-uninitialized-slot-value*)
    (dylan-call dylan:error "uninitialized slot accessed" object name)
    value)))

(define (make-class-getter class offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj) obj (object-ref (class.class-data class) offset class name))))

(define (make-each-subclass-getter class offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     (let ((class (instance.class obj)))
       (object-ref (class.class-data class) offset class name)))))

(define (make-instance-getter class offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     (object-ref (instance.data obj) offset obj name))))

(define (make-singleton-getter class singleton offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     obj                ; Ignored
     (object-ref (singleton.extra-slot-values singleton) offset
         singleton name))))

(define (make-class-setter class offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
     obj                ; Ignored
     (vector-set! (class.class-data class) offset value)
     value)
       (lambda (obj value)
     obj
     (dylan-call dylan:check-type value type)
     (vector-set! (class.class-data class) offset value)
     value))))

(define (make-each-subclass-setter class offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
     (vector-set! (class.class-data (instance.class obj)) offset value)
     value)
       (lambda (obj value)
     (dylan-call dylan:check-type value type)
     (vector-set! (class.class-data (instance.class obj)) offset value)
     value))))

(define (make-instance-setter class offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
     (vector-set! (instance.data obj) offset value)
     value)
       (lambda (obj value)
     (dylan-call dylan:check-type value type)
     (vector-set! (instance.data obj) offset value)
     value))))

(define (make-singleton-setter class singleton offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
     obj                ; Ignored
     (vector-set! (singleton.extra-slot-values singleton) offset value)
     value)
       (lambda (obj value)
     obj
     (dylan-call dylan:check-type value type)
     (vector-set! (singleton.extra-slot-values singleton) offset value)
     value))))

(define (make-constant-getter class constant)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     obj                ;Ignored
     constant)))

(define (dylan::make-singleton object)
  (if (instance? object)
      (or (instance.singleton object)
      (let ((singleton (make-singleton object '#() '#())))
        (set-instance.singleton! object singleton)
        singleton))
      (make-singleton object '#() '#())))